Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume26/veos-2.0/part08

Text File | 1993-04-25 | 74.9 KB | 2,937 lines

Newsgroups: comp.sources.unix
From: [e-mail] (Geoffery Coco)
Subject: v26i191: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part08/16
Sender: [e-mail]
Approved: [e-mail]

Submitted-By: [e-mail] (Geoffery Coco)
Posting-Number: Volume 26, Issue 191
Archive-Name: veos-2.0/part08

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 8 (of 16)."
# Contents:  kernel_private/src/nancy/nancy_match.c
#   src/kernel_current/nancy/nancy_match.c
#   src/kernel_current/talk/socket.c src/xlisp/xcore/c/xldmem.c
# Wrapped by [e-mail] on Sun Apr 25 23:10:40 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'kernel_private/src/nancy/nancy_match.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'kernel_private/src/nancy/nancy_match.c'\"
else
echo shar: Extracting \"'kernel_private/src/nancy/nancy_match.c'\" \(17745 characters\)
sed "s/^X//" >'kernel_private/src/nancy/nancy_match.c' <<'END_OF_FILE'
X/****************************************************************************************
X *                                            *
X * file: nancy_match.c                                    *
X *                                            *
X * February 15, 1992:  Matching semantics for grouples.                           *
X *                                            *
X * by Geoffrey P. Coco at the HITLab, Seattle.                          *
X *                                            *
X ****************************************************************************************/
X
X/****************************************************************************************
X * Copyright (C) 1992  Geoffrey P. Coco, Human Interface Technology Lab, Seattle    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X *                          includes galore                    */
X
X#include "kernel.h"
X#include <malloc.h>
X#include <varargs.h>
X
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_MatchGrouple                                    */
X
XTVeosErr Nancy_MatchGrouple(pMatchSpec)
X    TPMatchRec        pMatchSpec;
X{
X    TVeosErr         iErr;
X
X    if (TESTFLAG(NANCY_ContentMask, pMatchSpec->pPatGr->iFlags))
X    iErr = Nancy_MatchContentGrouple(pMatchSpec);
X    else
X    iErr = Nancy_MatchPositionGrouple(pMatchSpec);
X
X    return(iErr);
X
X    } /* Nancy_MatchGrouple */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X *                       private routines                    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_MatchPositionGrouple                                */
X
XTVeosErr Nancy_MatchPositionGrouple(pMatchSpec)
X    TPMatchRec        pMatchSpec;
X{
X    int            iPatElts, iSrcElts;
X    int            iMoreSrcElts;
X    TPElt        pPatFinger, pSrcFinger;
X    TPGrouple        pPatGr, pSrcGr;
X    int            iPatIndex, iSrcIndex;
X
X    boolean        bMarked, bTouched;
X    boolean        bMarkWithin, bTouchWithin;
X    TPReplaceRec    pMarkPB = nil, pTouchPB = nil;
X    TVeosErr        iErr = VEOS_SUCCESS;
X
X    /** setup cached locals **/
X
X    pPatGr = pMatchSpec->pPatGr;
X    pSrcGr = pMatchSpec->pSrcGr;
X    iSrcElts = pSrcGr->iElts;
X    iPatElts = pPatGr->iElts;
X
X    bMarkWithin = TESTFLAG(NANCY_MarkWithinMask, pPatGr->iFlags);
X    bTouchWithin = TESTFLAG(NANCY_TouchWithinMask, pPatGr->iFlags);
X
X
X    /** setup replace and touch descriptors to pass back.
X     **/
X
X    if (bMarkWithin) {
X    Nancy_NewReplaceNode(&pMarkPB);
X    pMarkPB->pEnviron = pSrcGr;
X    }
X    if (bTouchWithin) {
X    Nancy_NewReplaceNode(&pTouchPB);
X    pTouchPB->pEnviron = pSrcGr;
X    }
X
X
X    /** pattern controls the flow
X     ** loop through each pattern element until...
X     ** - an element match fails, or
X     ** - we run out of src elements (pattern too big)
X     ** - we run out of pattern elements (pattern not sufficient)
X     **/
X
X    iSrcIndex = 0;
X    iPatIndex = 0;
X
X    while (iErr == VEOS_SUCCESS) {
X
X    /*******************************************************
X     ** first, pass the gauntlet of tests for continuance **
X     *******************************************************/
X
X    /** check for end of pattern **/
X
X    if (iPatIndex >= iPatElts) {
X        if (iSrcIndex != iSrcElts)
X        iErr = NANCY_PatTooShort;
X        break;
X        }
X
X
X    /** setup local info of current pattern element **/
X
X    pPatFinger = &pPatGr->pEltList[iPatIndex];
X    pSrcFinger = &pSrcGr->pEltList[iSrcIndex];
X
X    bMarked = TESTFLAG(NANCY_EltMarkMask, pPatFinger->iFlags);
X    bTouched = TESTFLAG(NANCY_EltTouchMask, pPatFinger->iFlags);
X
X
X    /** check for end of source,
X     ** and not about to insert,
X     ** and matching zero or more.
X     **/
X
X    if (iSrcIndex >= iSrcElts &&
X        pPatFinger->iType != GR_here &&
X        pPatFinger->iType != GR_theseall) {
X
X        /** must be more pattern elts, or would not have got this far **/
X
X        iErr = NANCY_SrcTooShort;
X        break;
X        }
X
X
X    /**********************************************
X     ** second, perform the element match itself **
X     **********************************************/
X
X    switch (pPatFinger->iType) {
X
X    case GR_theseall:
X        if (iSrcIndex < iSrcElts) {
X        if (bMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcElts - 1;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X            pMarkPB->iInsertElt = iSrcIndex;
X            }
X        else if (bTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcElts - 1;
X            pTouchPB->iZones ++;
X            }
X        iSrcIndex = iSrcElts;
X        }
X        iSrcIndex = iSrcIndex - 1;
X        break;
X
X    case GR_here:
X        pMarkPB->iInsertElt = iSrcIndex;
X        iSrcIndex = iSrcIndex - 1;
X        break;
X
X    case GR_these:
X        iMoreSrcElts = pPatFinger->u.iVal - 1;
X
X        if (iSrcIndex + iMoreSrcElts >= iSrcElts)
X        iErr = NANCY_SrcTooShort;
X
X        else {
X        if (bMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex + iMoreSrcElts;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X            pMarkPB->iInsertElt = iSrcIndex;
X            }
X        else if (bTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight =
X            iSrcIndex + iMoreSrcElts;
X            pTouchPB->iZones ++;
X            }
X        iSrcIndex += iMoreSrcElts;
X        }
X        break;
X
X    case GR_grouple:
X    case GR_vector:
X        if (pPatFinger->iType != pSrcFinger->iType)
X        iErr = NANCY_NoMatch;
X
X        else {
X        pMatchSpec->pSrcGr = pSrcFinger->u.pGr;
X        pMatchSpec->pPatGr = pPatFinger->u.pGr;
X
X        iErr = Nancy_MatchGrouple(pMatchSpec);
X
X        pMatchSpec->pSrcGr = pSrcGr;
X        pMatchSpec->pPatGr = pPatGr;
X
X        if (iErr == VEOS_SUCCESS) {
X            if (bMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X                pMarkPB->iInsertElt = iSrcIndex;
X            }
X            else if (bTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcIndex;
X            pTouchPB->iZones ++;
X            }
X            }
X        }
X        break;
X
X    default:
X        iErr = Nancy_EltIdentical(pPatFinger, pSrcFinger);
X        if (iErr == VEOS_SUCCESS) {
X        if (bMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X            pMarkPB->iInsertElt = iSrcIndex;
X            }
X        else if (bTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcIndex;
X            pTouchPB->iZones ++;
X            }
X        }
X        break;
X
X        } /* switch */
X
X    iPatIndex ++;
X    iSrcIndex ++;
X    }
X
X    /********************
X     ** third, cleanup **
X     ********************/
X
X    if (iErr != VEOS_SUCCESS) {
X
X    if (bMarkWithin)
X        Nancy_DisposeReplaceNode(pMarkPB);
X    if (bTouchWithin)
X        Nancy_DisposeReplaceNode(pTouchPB);
X    }
X    else {
X    if (bMarkWithin) {
X        pMarkPB->pNext = pMatchSpec->pReplaceList;
X        pMatchSpec->pReplaceList = pMarkPB;
X        }
X    if (bTouchWithin) {
X        pTouchPB->pNext = pMatchSpec->pTouchList;
X        pMatchSpec->pTouchList = pTouchPB;
X        }
X    }
X
X    return(iErr);
X
X    } /* MatchPositionGrouple */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_MatchContentGrouple                                */
X
XTVeosErr Nancy_MatchContentGrouple(pMatchSpec)
X    TPMatchRec        pMatchSpec;
X{
X    int            iPatElts;
X    int            iPatIndex;
X    TPElt        pWildElt, pPatElt;
X    TPGrouple        pPatGr;
X
X    boolean        bMarkWithin, bTouchWithin;
X    TPReplaceRec    pMarkPB = nil, pTouchPB = nil;
X    TVeosErr        iErr = VEOS_SUCCESS;
X
X
X    pPatGr = pMatchSpec->pPatGr;
X    iPatElts = pPatGr->iElts;
X
X
X    /** content addressable grouples are specified
X     ** very precisely.  ie, there must be at least
X     ** one element, and the last element must be a * form.
X     **
X     ** thus, if a pattern came this far...
X     ** it better have a * element in last location.
X     ** so, the last elt type must be GR_any or GR_some.
X     **/
X
X    pWildElt = &pPatGr->pEltList[iPatElts - 1];
X
X
X    /** don't match normally against * form **/
X    iPatElts --;
X
X
X    bMarkWithin = TESTFLAG(NANCY_MarkWithinMask, pPatGr->iFlags);
X    bTouchWithin = TESTFLAG(NANCY_TouchWithinMask, pPatGr->iFlags);
X
X    /** setup replace descriptor to pass back.
X     ** note, many descriptors can be created with one match...
X     ** for example, when the caller calls this function again
X     ** during a 'MatchMany' type match.
X     **/
X
X    if (bMarkWithin) {
X    Nancy_NewReplaceNode(&pMarkPB);
X    pMarkPB->pEnviron = pMatchSpec->pSrcGr;
X    }
X    if (bTouchWithin) {
X    Nancy_NewReplaceNode(&pTouchPB);
X    pTouchPB->pEnviron = pMatchSpec->pSrcGr;
X    }
X
X
X    /** pattern controls the flow
X     ** loop through each pattern element until...
X     ** - an element match fails, or
X     ** - we run out of pattern elements (match successful)
X     **/
X
X    for (iPatIndex = 0, pPatElt = pMatchSpec->pPatGr->pEltList;
X     iErr == VEOS_SUCCESS;
X     iPatIndex ++, pPatElt ++) {
X
X
X    /** check for end of pattern **/
X
X    if (iPatIndex >= iPatElts)
X        break;
X
X    /** void matches instantly, no match necessary **/
X
X    if (pPatElt->iType == GR_here)
X        pMarkPB->iInsertElt = 0;
X
X    /** match pattern element against each elt in src grouple **/
X
X    else
X        iErr = Nancy_MapMatch(pMatchSpec, iPatIndex, pMarkPB, pTouchPB);
X
X    } /* pattern element loop */
X
X
X
X    Nancy_MapRestore(pMatchSpec,
X             ((TESTFLAG(NANCY_EltMarkMask, pWildElt->iFlags) &&
X               iErr == VEOS_SUCCESS) ? TRUE : FALSE),
X             ((TESTFLAG(NANCY_EltTouchMask, pWildElt->iFlags) &&
X               iErr == VEOS_SUCCESS) ? TRUE : FALSE),
X             pMarkPB, pTouchPB);
X
X
X
X    /** cleanup **/
X
X    if (iErr != VEOS_SUCCESS) {
X
X    if (bMarkWithin)
X        Nancy_DisposeReplaceNode(pMarkPB);
X    if (bTouchWithin)
X        Nancy_DisposeReplaceNode(pTouchPB);
X    }
X    else {
X    if (bMarkWithin) {
X        pMarkPB->pNext = pMatchSpec->pReplaceList;
X        pMatchSpec->pReplaceList = pMarkPB;
X        }
X    if (bTouchWithin) {
X        pTouchPB->pNext = pMatchSpec->pTouchList;
X        pMatchSpec->pTouchList = pTouchPB;
X        }
X    }
X
X    return(iErr);
X
X    } /* MatchContentGrouple */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_MapMatch(pMatchSpec, iPatIndex, pMarkPB, pTouchPB)
X    TPMatchRec        pMatchSpec;
X    int            iPatIndex;
X    TPReplaceRec    pMarkPB, pTouchPB;
X{
X    int            iSrcElts, iSrcIndex;
X    TPElt        pSrcFinger, pPatElt;
X    TPGrouple        pSrcGr, pPatGr;
X    int            iMatches;
X    boolean        bPatMarked, bPatTouched;
X    TVeosErr        iErr = VEOS_SUCCESS;
X
X
X    pSrcGr = pMatchSpec->pSrcGr;
X    iSrcElts = pSrcGr->iElts;
X
X    pPatGr = pMatchSpec->pPatGr;
X    pPatElt = &pPatGr->pEltList[iPatIndex];
X
X    bPatMarked = TESTFLAG(NANCY_EltMarkMask, pPatElt->iFlags);
X    bPatTouched = TESTFLAG(NANCY_EltTouchMask, pPatElt->iFlags);
X
X#ifndef OPTIMAL
X    if (NANCY_BUGS) {
X    fprintf(stderr, "matching:  ");
X    Nancy_ElementToStream(pPatElt, stderr);
X    fprintf(stderr, "against:  ");
X    Nancy_GroupleToStream(pSrcGr, stderr);
X    }
X#endif
X
X    /** perform exhaustive search for pat
X     ** element through the source grouple.
X     **/
X    iMatches = 0;
X
X    switch (pPatElt->iType) {
X
X    case GR_grouple:
X    case GR_vector:
X    for (iSrcIndex = 0, pSrcFinger = pSrcGr->pEltList;
X         iSrcIndex < iSrcElts;
X         iSrcIndex ++, pSrcFinger ++) {
X
X        if (pPatElt->iType == pSrcFinger->iType) {
X
X        pMatchSpec->pSrcGr = pSrcFinger->u.pGr;
X        pMatchSpec->pPatGr = pPatElt->u.pGr;
X
X        iErr = Nancy_MatchGrouple(pMatchSpec);
X
X        pMatchSpec->pSrcGr = pSrcGr;
X        pMatchSpec->pPatGr = pPatGr;
X
X        if (iErr == VEOS_SUCCESS) {
X
X            if (bPatMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X                pMarkPB->iInsertElt = iSrcIndex;
X            }
X            else if (bPatTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcIndex;
X            pTouchPB->iZones ++;
X            }
X
X            iMatches ++;
X
X            if (NANCY_BUGS) {
X            fprintf(stderr, "matched on:    ");
X            Nancy_ElementToStream(pSrcFinger, stderr);
X            }
X
X            /** mark src element as having been matched **/
X            SETFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags);
X
X            if (pMatchSpec->iFreqFlag == NANCY_MatchOne)
X            break;
X
X            } /* matched */
X        } /* same type */
X        } /* for */
X    break;
X
X    default:
X    for (iSrcIndex = 0, pSrcFinger = pSrcGr->pEltList;
X         iSrcIndex < iSrcElts;
X         iSrcIndex ++, pSrcFinger ++) {
X
X        if (pPatElt->iType == pSrcFinger->iType &&
X        Nancy_EltIdentical(pPatElt, pSrcFinger) == VEOS_SUCCESS) {
X
X        if (bPatMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X            pMarkPB->iInsertElt = iSrcIndex;
X            }
X        else if (bPatTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcIndex;
X            pTouchPB->iZones ++;
X            }
X
X        iMatches ++;
X
X        if (NANCY_BUGS) {
X            fprintf(stderr, "matched on:    ");
X            Nancy_ElementToStream(pSrcFinger, stderr);
X            }
X
X        /** mark src element as having been matched **/
X        SETFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags);
X
X        if (pMatchSpec->iFreqFlag == NANCY_MatchOne)
X            break;
X
X        } /* matched */
X        } /* for */
X    break;
X
X    } /* switch */
X
X    if (iMatches == 0)
X    iErr = NANCY_NoMatch;
X    else
X    iErr = VEOS_SUCCESS;
X
X    return(iErr);
X
X    } /* Nancy_MapMatch */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_MapRestore(pMatchSpec, bGatherUnmatched, bTouchUnmatched, pMarkPB, pTouchPB)
X    TPMatchRec        pMatchSpec;
X    boolean        bGatherUnmatched, bTouchUnmatched;
X    TPReplaceRec    pMarkPB, pTouchPB;
X{
X    int            iSrcIndex, iSrcElts;
X    TPElt        pSrcFinger;
X    TVeosErr        iErr = VEOS_SUCCESS;
X
X    iSrcElts = pMatchSpec->pSrcGr->iElts;
X
X    if (bGatherUnmatched) {
X
X    for (iSrcIndex = 0, pSrcFinger = pMatchSpec->pSrcGr->pEltList;
X         iSrcIndex < iSrcElts;
X         iSrcIndex ++, pSrcFinger ++) {
X
X        if (TESTFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags)) {
X
X        /** clear the source marks **/
X        CLRFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags);
X        }
X
X        else {
X        /** gather unmatched elements into replace list **/
X
X        if (pMarkPB->pWipeList[pMarkPB->iZones - 1].iRight == (iSrcIndex - 1))
X            pMarkPB->pWipeList[pMarkPB->iZones - 1].iRight = iSrcIndex;
X        else {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex;
X            pMarkPB->iZones ++;
X            }
X        }
X        } /* for */
X    } /* gather marked */
X
X    else if (bTouchUnmatched) {
X
X    for (iSrcIndex = 0, pSrcFinger = pMatchSpec->pSrcGr->pEltList;
X         iSrcIndex < iSrcElts;
X         iSrcIndex ++, pSrcFinger ++) {
X
X        if (TESTFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags)) {
X
X        /** clear the source marks **/
X        CLRFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags);
X        }
X
X        else {
X        /** gather unmatched elements into touch list **/
X
X        if (pTouchPB->pWipeList[pTouchPB->iZones - 1].iRight == (iSrcIndex - 1))
X            pTouchPB->pWipeList[pTouchPB->iZones - 1].iRight = iSrcIndex;
X        else {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcIndex;
X            pTouchPB->iZones ++;
X            }
X        }
X        } /* for */
X    } /* gather touch */
X
X    return(iErr);
X
X    } /* Nancy_MapRestore */
X/****************************************************************************************
X
X
X
X/****************************************************************************************
X * Nancy_NewReplaceNode                                    */
X
XTVeosErr Nancy_NewReplaceNode(hNode)
X    THReplaceRec    hNode;
X{
X    TVeosErr         iErr;
X    TPReplaceRec    pNode;
X
X    iErr = Shell_NewBlock(sizeof(TReplaceRec), &pNode, "replace-bp");
X    if (iErr == VEOS_SUCCESS) {
X    pNode->pEnviron = nil;
X    pNode->iZones = 0;
X    pNode->iInsertElt = -1;
X    pNode->pNext = nil;
X    }
X
X    *hNode = pNode;
X
X    return(iErr);
X
X    } /* Nancy_NewReplaceNode */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_DisposeReplaceNode                                */
X
XTVeosErr Nancy_DisposeReplaceNode(pNode)
X    TPReplaceRec    pNode;
X{
X    TVeosErr         iErr;
X
X    iErr = Shell_ReturnBlock(pNode, sizeof(TReplaceRec), "replace-bp");
X
X    return(iErr);
X
X    } /* Nancy_DisposeReplaceNode */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_                                        */
X
XTVeosErr Nancy_()
X{
X    TVeosErr         iErr;
X
X
X    return(iErr);
X
X    } /* Nancy_ */
X/****************************************************************************************/
X
END_OF_FILE
if test 17745 -ne `wc -c <'kernel_private/src/nancy/nancy_match.c'`; then
    echo shar: \"'kernel_private/src/nancy/nancy_match.c'\" unpacked with wrong size!
fi
# end of 'kernel_private/src/nancy/nancy_match.c'
fi
if test -f 'src/kernel_current/nancy/nancy_match.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/kernel_current/nancy/nancy_match.c'\"
else
echo shar: Extracting \"'src/kernel_current/nancy/nancy_match.c'\" \(17745 characters\)
sed "s/^X//" >'src/kernel_current/nancy/nancy_match.c' <<'END_OF_FILE'
X/****************************************************************************************
X *                                            *
X * file: nancy_match.c                                    *
X *                                            *
X * February 15, 1992:  Matching semantics for grouples.                           *
X *                                            *
X * by Geoffrey P. Coco at the HITLab, Seattle.                          *
X *                                            *
X ****************************************************************************************/
X
X/****************************************************************************************
X * Copyright (C) 1992  Geoffrey P. Coco, Human Interface Technology Lab, Seattle    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X *                          includes galore                    */
X
X#include "kernel.h"
X#include <malloc.h>
X#include <varargs.h>
X
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_MatchGrouple                                    */
X
XTVeosErr Nancy_MatchGrouple(pMatchSpec)
X    TPMatchRec        pMatchSpec;
X{
X    TVeosErr         iErr;
X
X    if (TESTFLAG(NANCY_ContentMask, pMatchSpec->pPatGr->iFlags))
X    iErr = Nancy_MatchContentGrouple(pMatchSpec);
X    else
X    iErr = Nancy_MatchPositionGrouple(pMatchSpec);
X
X    return(iErr);
X
X    } /* Nancy_MatchGrouple */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X *                       private routines                    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_MatchPositionGrouple                                */
X
XTVeosErr Nancy_MatchPositionGrouple(pMatchSpec)
X    TPMatchRec        pMatchSpec;
X{
X    int            iPatElts, iSrcElts;
X    int            iMoreSrcElts;
X    TPElt        pPatFinger, pSrcFinger;
X    TPGrouple        pPatGr, pSrcGr;
X    int            iPatIndex, iSrcIndex;
X
X    boolean        bMarked, bTouched;
X    boolean        bMarkWithin, bTouchWithin;
X    TPReplaceRec    pMarkPB = nil, pTouchPB = nil;
X    TVeosErr        iErr = VEOS_SUCCESS;
X
X    /** setup cached locals **/
X
X    pPatGr = pMatchSpec->pPatGr;
X    pSrcGr = pMatchSpec->pSrcGr;
X    iSrcElts = pSrcGr->iElts;
X    iPatElts = pPatGr->iElts;
X
X    bMarkWithin = TESTFLAG(NANCY_MarkWithinMask, pPatGr->iFlags);
X    bTouchWithin = TESTFLAG(NANCY_TouchWithinMask, pPatGr->iFlags);
X
X
X    /** setup replace and touch descriptors to pass back.
X     **/
X
X    if (bMarkWithin) {
X    Nancy_NewReplaceNode(&pMarkPB);
X    pMarkPB->pEnviron = pSrcGr;
X    }
X    if (bTouchWithin) {
X    Nancy_NewReplaceNode(&pTouchPB);
X    pTouchPB->pEnviron = pSrcGr;
X    }
X
X
X    /** pattern controls the flow
X     ** loop through each pattern element until...
X     ** - an element match fails, or
X     ** - we run out of src elements (pattern too big)
X     ** - we run out of pattern elements (pattern not sufficient)
X     **/
X
X    iSrcIndex = 0;
X    iPatIndex = 0;
X
X    while (iErr == VEOS_SUCCESS) {
X
X    /*******************************************************
X     ** first, pass the gauntlet of tests for continuance **
X     *******************************************************/
X
X    /** check for end of pattern **/
X
X    if (iPatIndex >= iPatElts) {
X        if (iSrcIndex != iSrcElts)
X        iErr = NANCY_PatTooShort;
X        break;
X        }
X
X
X    /** setup local info of current pattern element **/
X
X    pPatFinger = &pPatGr->pEltList[iPatIndex];
X    pSrcFinger = &pSrcGr->pEltList[iSrcIndex];
X
X    bMarked = TESTFLAG(NANCY_EltMarkMask, pPatFinger->iFlags);
X    bTouched = TESTFLAG(NANCY_EltTouchMask, pPatFinger->iFlags);
X
X
X    /** check for end of source,
X     ** and not about to insert,
X     ** and matching zero or more.
X     **/
X
X    if (iSrcIndex >= iSrcElts &&
X        pPatFinger->iType != GR_here &&
X        pPatFinger->iType != GR_theseall) {
X
X        /** must be more pattern elts, or would not have got this far **/
X
X        iErr = NANCY_SrcTooShort;
X        break;
X        }
X
X
X    /**********************************************
X     ** second, perform the element match itself **
X     **********************************************/
X
X    switch (pPatFinger->iType) {
X
X    case GR_theseall:
X        if (iSrcIndex < iSrcElts) {
X        if (bMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcElts - 1;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X            pMarkPB->iInsertElt = iSrcIndex;
X            }
X        else if (bTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcElts - 1;
X            pTouchPB->iZones ++;
X            }
X        iSrcIndex = iSrcElts;
X        }
X        iSrcIndex = iSrcIndex - 1;
X        break;
X
X    case GR_here:
X        pMarkPB->iInsertElt = iSrcIndex;
X        iSrcIndex = iSrcIndex - 1;
X        break;
X
X    case GR_these:
X        iMoreSrcElts = pPatFinger->u.iVal - 1;
X
X        if (iSrcIndex + iMoreSrcElts >= iSrcElts)
X        iErr = NANCY_SrcTooShort;
X
X        else {
X        if (bMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex + iMoreSrcElts;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X            pMarkPB->iInsertElt = iSrcIndex;
X            }
X        else if (bTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight =
X            iSrcIndex + iMoreSrcElts;
X            pTouchPB->iZones ++;
X            }
X        iSrcIndex += iMoreSrcElts;
X        }
X        break;
X
X    case GR_grouple:
X    case GR_vector:
X        if (pPatFinger->iType != pSrcFinger->iType)
X        iErr = NANCY_NoMatch;
X
X        else {
X        pMatchSpec->pSrcGr = pSrcFinger->u.pGr;
X        pMatchSpec->pPatGr = pPatFinger->u.pGr;
X
X        iErr = Nancy_MatchGrouple(pMatchSpec);
X
X        pMatchSpec->pSrcGr = pSrcGr;
X        pMatchSpec->pPatGr = pPatGr;
X
X        if (iErr == VEOS_SUCCESS) {
X            if (bMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X                pMarkPB->iInsertElt = iSrcIndex;
X            }
X            else if (bTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcIndex;
X            pTouchPB->iZones ++;
X            }
X            }
X        }
X        break;
X
X    default:
X        iErr = Nancy_EltIdentical(pPatFinger, pSrcFinger);
X        if (iErr == VEOS_SUCCESS) {
X        if (bMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X            pMarkPB->iInsertElt = iSrcIndex;
X            }
X        else if (bTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcIndex;
X            pTouchPB->iZones ++;
X            }
X        }
X        break;
X
X        } /* switch */
X
X    iPatIndex ++;
X    iSrcIndex ++;
X    }
X
X    /********************
X     ** third, cleanup **
X     ********************/
X
X    if (iErr != VEOS_SUCCESS) {
X
X    if (bMarkWithin)
X        Nancy_DisposeReplaceNode(pMarkPB);
X    if (bTouchWithin)
X        Nancy_DisposeReplaceNode(pTouchPB);
X    }
X    else {
X    if (bMarkWithin) {
X        pMarkPB->pNext = pMatchSpec->pReplaceList;
X        pMatchSpec->pReplaceList = pMarkPB;
X        }
X    if (bTouchWithin) {
X        pTouchPB->pNext = pMatchSpec->pTouchList;
X        pMatchSpec->pTouchList = pTouchPB;
X        }
X    }
X
X    return(iErr);
X
X    } /* MatchPositionGrouple */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_MatchContentGrouple                                */
X
XTVeosErr Nancy_MatchContentGrouple(pMatchSpec)
X    TPMatchRec        pMatchSpec;
X{
X    int            iPatElts;
X    int            iPatIndex;
X    TPElt        pWildElt, pPatElt;
X    TPGrouple        pPatGr;
X
X    boolean        bMarkWithin, bTouchWithin;
X    TPReplaceRec    pMarkPB = nil, pTouchPB = nil;
X    TVeosErr        iErr = VEOS_SUCCESS;
X
X
X    pPatGr = pMatchSpec->pPatGr;
X    iPatElts = pPatGr->iElts;
X
X
X    /** content addressable grouples are specified
X     ** very precisely.  ie, there must be at least
X     ** one element, and the last element must be a * form.
X     **
X     ** thus, if a pattern came this far...
X     ** it better have a * element in last location.
X     ** so, the last elt type must be GR_any or GR_some.
X     **/
X
X    pWildElt = &pPatGr->pEltList[iPatElts - 1];
X
X
X    /** don't match normally against * form **/
X    iPatElts --;
X
X
X    bMarkWithin = TESTFLAG(NANCY_MarkWithinMask, pPatGr->iFlags);
X    bTouchWithin = TESTFLAG(NANCY_TouchWithinMask, pPatGr->iFlags);
X
X    /** setup replace descriptor to pass back.
X     ** note, many descriptors can be created with one match...
X     ** for example, when the caller calls this function again
X     ** during a 'MatchMany' type match.
X     **/
X
X    if (bMarkWithin) {
X    Nancy_NewReplaceNode(&pMarkPB);
X    pMarkPB->pEnviron = pMatchSpec->pSrcGr;
X    }
X    if (bTouchWithin) {
X    Nancy_NewReplaceNode(&pTouchPB);
X    pTouchPB->pEnviron = pMatchSpec->pSrcGr;
X    }
X
X
X    /** pattern controls the flow
X     ** loop through each pattern element until...
X     ** - an element match fails, or
X     ** - we run out of pattern elements (match successful)
X     **/
X
X    for (iPatIndex = 0, pPatElt = pMatchSpec->pPatGr->pEltList;
X     iErr == VEOS_SUCCESS;
X     iPatIndex ++, pPatElt ++) {
X
X
X    /** check for end of pattern **/
X
X    if (iPatIndex >= iPatElts)
X        break;
X
X    /** void matches instantly, no match necessary **/
X
X    if (pPatElt->iType == GR_here)
X        pMarkPB->iInsertElt = 0;
X
X    /** match pattern element against each elt in src grouple **/
X
X    else
X        iErr = Nancy_MapMatch(pMatchSpec, iPatIndex, pMarkPB, pTouchPB);
X
X    } /* pattern element loop */
X
X
X
X    Nancy_MapRestore(pMatchSpec,
X             ((TESTFLAG(NANCY_EltMarkMask, pWildElt->iFlags) &&
X               iErr == VEOS_SUCCESS) ? TRUE : FALSE),
X             ((TESTFLAG(NANCY_EltTouchMask, pWildElt->iFlags) &&
X               iErr == VEOS_SUCCESS) ? TRUE : FALSE),
X             pMarkPB, pTouchPB);
X
X
X
X    /** cleanup **/
X
X    if (iErr != VEOS_SUCCESS) {
X
X    if (bMarkWithin)
X        Nancy_DisposeReplaceNode(pMarkPB);
X    if (bTouchWithin)
X        Nancy_DisposeReplaceNode(pTouchPB);
X    }
X    else {
X    if (bMarkWithin) {
X        pMarkPB->pNext = pMatchSpec->pReplaceList;
X        pMatchSpec->pReplaceList = pMarkPB;
X        }
X    if (bTouchWithin) {
X        pTouchPB->pNext = pMatchSpec->pTouchList;
X        pMatchSpec->pTouchList = pTouchPB;
X        }
X    }
X
X    return(iErr);
X
X    } /* MatchContentGrouple */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_MapMatch(pMatchSpec, iPatIndex, pMarkPB, pTouchPB)
X    TPMatchRec        pMatchSpec;
X    int            iPatIndex;
X    TPReplaceRec    pMarkPB, pTouchPB;
X{
X    int            iSrcElts, iSrcIndex;
X    TPElt        pSrcFinger, pPatElt;
X    TPGrouple        pSrcGr, pPatGr;
X    int            iMatches;
X    boolean        bPatMarked, bPatTouched;
X    TVeosErr        iErr = VEOS_SUCCESS;
X
X
X    pSrcGr = pMatchSpec->pSrcGr;
X    iSrcElts = pSrcGr->iElts;
X
X    pPatGr = pMatchSpec->pPatGr;
X    pPatElt = &pPatGr->pEltList[iPatIndex];
X
X    bPatMarked = TESTFLAG(NANCY_EltMarkMask, pPatElt->iFlags);
X    bPatTouched = TESTFLAG(NANCY_EltTouchMask, pPatElt->iFlags);
X
X#ifndef OPTIMAL
X    if (NANCY_BUGS) {
X    fprintf(stderr, "matching:  ");
X    Nancy_ElementToStream(pPatElt, stderr);
X    fprintf(stderr, "against:  ");
X    Nancy_GroupleToStream(pSrcGr, stderr);
X    }
X#endif
X
X    /** perform exhaustive search for pat
X     ** element through the source grouple.
X     **/
X    iMatches = 0;
X
X    switch (pPatElt->iType) {
X
X    case GR_grouple:
X    case GR_vector:
X    for (iSrcIndex = 0, pSrcFinger = pSrcGr->pEltList;
X         iSrcIndex < iSrcElts;
X         iSrcIndex ++, pSrcFinger ++) {
X
X        if (pPatElt->iType == pSrcFinger->iType) {
X
X        pMatchSpec->pSrcGr = pSrcFinger->u.pGr;
X        pMatchSpec->pPatGr = pPatElt->u.pGr;
X
X        iErr = Nancy_MatchGrouple(pMatchSpec);
X
X        pMatchSpec->pSrcGr = pSrcGr;
X        pMatchSpec->pPatGr = pPatGr;
X
X        if (iErr == VEOS_SUCCESS) {
X
X            if (bPatMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X                pMarkPB->iInsertElt = iSrcIndex;
X            }
X            else if (bPatTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcIndex;
X            pTouchPB->iZones ++;
X            }
X
X            iMatches ++;
X
X            if (NANCY_BUGS) {
X            fprintf(stderr, "matched on:    ");
X            Nancy_ElementToStream(pSrcFinger, stderr);
X            }
X
X            /** mark src element as having been matched **/
X            SETFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags);
X
X            if (pMatchSpec->iFreqFlag == NANCY_MatchOne)
X            break;
X
X            } /* matched */
X        } /* same type */
X        } /* for */
X    break;
X
X    default:
X    for (iSrcIndex = 0, pSrcFinger = pSrcGr->pEltList;
X         iSrcIndex < iSrcElts;
X         iSrcIndex ++, pSrcFinger ++) {
X
X        if (pPatElt->iType == pSrcFinger->iType &&
X        Nancy_EltIdentical(pPatElt, pSrcFinger) == VEOS_SUCCESS) {
X
X        if (bPatMarked) {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex;
X            pMarkPB->iZones ++;
X            if (pMatchSpec->iDestroyFlag == NANCY_ReplaceMatch)
X            pMarkPB->iInsertElt = iSrcIndex;
X            }
X        else if (bPatTouched) {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcIndex;
X            pTouchPB->iZones ++;
X            }
X
X        iMatches ++;
X
X        if (NANCY_BUGS) {
X            fprintf(stderr, "matched on:    ");
X            Nancy_ElementToStream(pSrcFinger, stderr);
X            }
X
X        /** mark src element as having been matched **/
X        SETFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags);
X
X        if (pMatchSpec->iFreqFlag == NANCY_MatchOne)
X            break;
X
X        } /* matched */
X        } /* for */
X    break;
X
X    } /* switch */
X
X    if (iMatches == 0)
X    iErr = NANCY_NoMatch;
X    else
X    iErr = VEOS_SUCCESS;
X
X    return(iErr);
X
X    } /* Nancy_MapMatch */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_MapRestore(pMatchSpec, bGatherUnmatched, bTouchUnmatched, pMarkPB, pTouchPB)
X    TPMatchRec        pMatchSpec;
X    boolean        bGatherUnmatched, bTouchUnmatched;
X    TPReplaceRec    pMarkPB, pTouchPB;
X{
X    int            iSrcIndex, iSrcElts;
X    TPElt        pSrcFinger;
X    TVeosErr        iErr = VEOS_SUCCESS;
X
X    iSrcElts = pMatchSpec->pSrcGr->iElts;
X
X    if (bGatherUnmatched) {
X
X    for (iSrcIndex = 0, pSrcFinger = pMatchSpec->pSrcGr->pEltList;
X         iSrcIndex < iSrcElts;
X         iSrcIndex ++, pSrcFinger ++) {
X
X        if (TESTFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags)) {
X
X        /** clear the source marks **/
X        CLRFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags);
X        }
X
X        else {
X        /** gather unmatched elements into replace list **/
X
X        if (pMarkPB->pWipeList[pMarkPB->iZones - 1].iRight == (iSrcIndex - 1))
X            pMarkPB->pWipeList[pMarkPB->iZones - 1].iRight = iSrcIndex;
X        else {
X            pMarkPB->pWipeList[pMarkPB->iZones].iLeft = iSrcIndex;
X            pMarkPB->pWipeList[pMarkPB->iZones].iRight = iSrcIndex;
X            pMarkPB->iZones ++;
X            }
X        }
X        } /* for */
X    } /* gather marked */
X
X    else if (bTouchUnmatched) {
X
X    for (iSrcIndex = 0, pSrcFinger = pMatchSpec->pSrcGr->pEltList;
X         iSrcIndex < iSrcElts;
X         iSrcIndex ++, pSrcFinger ++) {
X
X        if (TESTFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags)) {
X
X        /** clear the source marks **/
X        CLRFLAG(NANCY_EltMatchMask, pSrcFinger->iFlags);
X        }
X
X        else {
X        /** gather unmatched elements into touch list **/
X
X        if (pTouchPB->pWipeList[pTouchPB->iZones - 1].iRight == (iSrcIndex - 1))
X            pTouchPB->pWipeList[pTouchPB->iZones - 1].iRight = iSrcIndex;
X        else {
X            pTouchPB->pWipeList[pTouchPB->iZones].iLeft = iSrcIndex;
X            pTouchPB->pWipeList[pTouchPB->iZones].iRight = iSrcIndex;
X            pTouchPB->iZones ++;
X            }
X        }
X        } /* for */
X    } /* gather touch */
X
X    return(iErr);
X
X    } /* Nancy_MapRestore */
X/****************************************************************************************
X
X
X
X/****************************************************************************************
X * Nancy_NewReplaceNode                                    */
X
XTVeosErr Nancy_NewReplaceNode(hNode)
X    THReplaceRec    hNode;
X{
X    TVeosErr         iErr;
X    TPReplaceRec    pNode;
X
X    iErr = Shell_NewBlock(sizeof(TReplaceRec), &pNode, "replace-bp");
X    if (iErr == VEOS_SUCCESS) {
X    pNode->pEnviron = nil;
X    pNode->iZones = 0;
X    pNode->iInsertElt = -1;
X    pNode->pNext = nil;
X    }
X
X    *hNode = pNode;
X
X    return(iErr);
X
X    } /* Nancy_NewReplaceNode */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_DisposeReplaceNode                                */
X
XTVeosErr Nancy_DisposeReplaceNode(pNode)
X    TPReplaceRec    pNode;
X{
X    TVeosErr         iErr;
X
X    iErr = Shell_ReturnBlock(pNode, sizeof(TReplaceRec), "replace-bp");
X
X    return(iErr);
X
X    } /* Nancy_DisposeReplaceNode */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_                                        */
X
XTVeosErr Nancy_()
X{
X    TVeosErr         iErr;
X
X
X    return(iErr);
X
X    } /* Nancy_ */
X/****************************************************************************************/
X
END_OF_FILE
if test 17745 -ne `wc -c <'src/kernel_current/nancy/nancy_match.c'`; then
    echo shar: \"'src/kernel_current/nancy/nancy_match.c'\" unpacked with wrong size!
fi
# end of 'src/kernel_current/nancy/nancy_match.c'
fi
if test -f 'src/kernel_current/talk/socket.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/kernel_current/talk/socket.c'\"
else
echo shar: Extracting \"'src/kernel_current/talk/socket.c'\" \(16709 characters\)
sed "s/^X//" >'src/kernel_current/talk/socket.c' <<'END_OF_FILE'
X/****************************************************************************************
X *                                            *
X * file: socket.c                                                *
X *                                            *
X * November 14, 1990: The network and transport layer for inter-entity message passing    *
X *               library, 'talk' for the VEOS project.                             *
X *                                            *
X * by Geoffrey P. Coco at the HITLab, Seattle.                          *
X * these functions are based on BSD socket code by Dan Pezely.                       *
X *                                            *
X ****************************************************************************************/
X
X/****************************************************************************************
X * Copyright (C) 1992  Geoffrey P. Coco, Human Interface Technology Lab, Seattle    *
X ****************************************************************************************/
X
X
X
X/****************************************************************************************
X *                      include the papa include file                */
X
X#include "kernel.h"
X
X#include <sys/types.h>
X#include <sys/socket.h>
X#include <netinet/in.h>
X#include <netinet/tcp.h>
X#include <netdb.h>            /* for get_*_byname() */
X#include <stropts.h>            /* ioctl() streamio */
X#include <fcntl.h>
X#include "signal.h"
X
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X *                     forward function declarations                */
X
XTVeosErr Sock_Connect();
XTVeosErr Sock_Listen();
XTVeosErr Sock_ReadSelect();
XTVeosErr Sock_WriteSelect();
XTVeosErr Sock_Accept();
XTVeosErr Sock_Transmit();
XTVeosErr Sock_Receive();
XTVeosErr Sock_Close();
X
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X *                     local function declarations                */
X
XTVeosErr Sock_MixItUp();
XTVeosErr Sock_ResolveHost();
Xu_long Sock_ConvertAddr();
X
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Sock_Connect(iSocketFD, pUid, sProtocolName)
X    int         *iSocketFD;
X    TPUid        pUid;
X    char         *sProtocolName;
X{
X    struct sockaddr_in  socketName;
X    TVeosErr        iErr;
X    int            iProto, iOption, iBufSize;
X
X
X    /** translate given network params into useable form **/
X
X    iErr = Sock_MixItUp(&pUid->iPort, sProtocolName, &iProto);
X    if (iErr == VEOS_SUCCESS) {
X
X
X    /** copy the address of the receiving host **/
X
X    socketName.sin_addr.s_addr = pUid->lHost;
X
X
X    /** create socket with specified protocol **/
X
X    socketName.sin_family = AF_INET;
X    socketName.sin_port = htons(pUid->iPort);
X
X    *iSocketFD = socket(socketName.sin_family, SOCK_STREAM, iProto);
X
X    if (*iSocketFD == TALK_BOGUS_FD)
X        iErr = TALK_CREATE;
X
X    else {
X
X
X        /** attempt to connect to given address **/
X
X        if (connect(*iSocketFD, &socketName, sizeof(socketName)) < 0)
X
X        iErr = TALK_CONNECT;
X
X
X        else {
X/*
X        iBufSize = 16384;
X        if (setsockopt(*iSocketFD, SOL_SOCKET, SO_SNDBUF,
X                   (char *) &iBufSize, sizeof(int)) < 0)
X            iErr = TALK_FLAGS;
X*/
X        iOption = TRUE;
X        if (setsockopt(*iSocketFD, IPPROTO_TCP, TCP_NODELAY,
X                   &iOption, sizeof(int)) == -1)
X            iErr = TALK_FLAGS;
X
X        /** set non-blocking write bit **/
X
X        fcntl(*iSocketFD, F_SETFL, FNDELAY);
X
X        FD_SET(*iSocketFD, &OPEN_WRITE_SOCKETS);
X        }
X
X        if (iErr != VEOS_SUCCESS)
X        Sock_Close(iSocketFD);
X        }
X    }
X
X    return(iErr);
X
X    } /* Sock_Connect */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Sock_Listen(iSocketFD, iPortNumber, sProtocolName, iAttitude)
X    int         *iSocketFD;
X    int         iPortNumber;
X    char         *sProtocolName;
X    int            iAttitude;
X{
X    struct sockaddr_in  socketName;
X    TVeosErr        iErr;
X    int            iProto, iOption;
X    int            iZoot;
X
X    iErr = Sock_MixItUp(&iPortNumber, sProtocolName, &iProto);
X    if (iErr == VEOS_SUCCESS) {
X
X
X
X    /** create socket with specified protocol **/
X
X    socketName.sin_family = AF_INET;   /* specify socket to be of INTERNET family */
X
X    *iSocketFD = socket(socketName.sin_family, SOCK_STREAM, iProto);
X
X    if (*iSocketFD == TALK_BOGUS_FD)
X        iErr = TALK_CREATE;
X
X    else {
X        socketName.sin_addr.s_addr = htonl(INADDR_ANY);
X        socketName.sin_port = htons(iPortNumber);
X
X        if (iAttitude == TALK_AGRESSIVE) {
X        iOption = TRUE;
X        if (setsockopt(*iSocketFD, SOL_SOCKET, SO_REUSEADDR,
X                   &iOption, sizeof(int)) == -1)
X            iErr = TALK_FLAGS;
X        }
X
X        if (iErr == VEOS_SUCCESS) {
X
X        /** register this socket with system for us **/
X
X        if (bind(*iSocketFD, &socketName, sizeof(socketName)) < 0) {
X
X            iErr = TALK_BIND;
X            }
X
X        else {
X            /** listen on the socket **/
X
X            if (listen(*iSocketFD, TALK_QUEUE_SIZE ) < 0)
X            iErr = TALK_LISTEN;
X
X            else {
X            /** have this socket generate an interrupt
X             ** when another entity connects.
X             **/
X/*
X            fcntl(*iSocketFD, F_SETOWN, getpid());
X            fcntl(*iSocketFD, F_SETFL, FASYNC);
X*/
X            FD_SET(*iSocketFD, &OPEN_READ_SOCKETS);
X            }
X            }
X        }
X        }
X    if (iErr != VEOS_SUCCESS) {
X
X        Sock_Close(iSocketFD);
X        *iSocketFD = TALK_BOGUS_FD;
X        }
X    }
X
X    return(iErr);
X
X    } /* Sock_Listen */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Sock_ReadSelect(iSocketFD)
X    int        iSocketFD;
X{
X    struct timeval      timeVal;
X    fd_set          tempFDSet;
X    int         iSize;
X    TVeosErr        iErr;
X
X
X    iErr = VEOS_SUCCESS;
X
X
X    /** create a local copy of the fd_set since it gets modified by select() **/
X
X    bcopy((char*) &OPEN_READ_SOCKETS, (char*) &tempFDSet, sizeof(fd_set));
X
X
X
X    /** some implementations of select() might modify timeVal, so we    **
X     ** must keep resetting it rather then making it global or static.    **/
X
X    timeVal.tv_sec = 0;
X    timeVal.tv_usec = 0;
X
X    iSize = select(FD_SETSIZE, &tempFDSet, nil, nil, &timeVal);
X
X    if (iSize <  0)
X    iErr = TALK_SELECT;
X
X    else if (iSize == 0)
X    iErr = TALK_SELECT_TIMEOUT;
X
X    else if (!FD_ISSET(iSocketFD, &tempFDSet))
X    iErr = TALK_NOCONN;
X
X
X    return(iErr);
X
X    } /* Sock_ReadSelect */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Sock_ReadSelect                                    */
X
XTVeosErr Sock_WriteSelect(iSocketFD)
X     int        iSocketFD;
X{
X    struct timeval      timeVal;
X    fd_set          tempFDSet;
X    int         iSize;
X    TVeosErr        iErr;
X
X
X    iErr = VEOS_SUCCESS;
X
X
X    /** create a local copy of the fd_set since it gets modified by select() **/
X
X    bcopy((char*) &OPEN_WRITE_SOCKETS, (char*) &tempFDSet, sizeof(fd_set));
X
X
X
X    /** some implementations of select() might modify timeVal, so we    **
X     ** must keep resetting it rather then making it global or static.    **/
X
X    timeVal.tv_sec = 0;
X    timeVal.tv_usec = 0;
X
X    iSize = select(FD_SETSIZE, nil, &tempFDSet, nil, &timeVal);
X
X    if (TRAP_FLAGS & 0x00000001 << SIGPIPE) {
X    TRAP_FLAGS = TRAP_FLAGS & ~(0x00000001 << SIGPIPE);
X    TERMINATE = FALSE;
X    iErr = TALK_CONN_CLOSED;
X    }
X
X    else if (iSize <  0)
X    iErr = TALK_SELECT;
X
X    else if (iSize == 0)
X    iErr = TALK_SELECT_TIMEOUT;
X
X    else if (!FD_ISSET(iSocketFD, &tempFDSet))
X    iErr = TALK_NOCONN;
X
X
X    return(iErr);
X
X    } /* Sock_WriteSelect */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Sock_Accept                                        */
X
XTVeosErr Sock_Accept(iSocketFD, iSocketIOFD)
X    int         iSocketFD;
X    int         *iSocketIOFD;
X{
X    TVeosErr        iErr;
X    int            iBufSize;
X
X    iErr = TALK_ACCEPT;
X
X    *iSocketIOFD = accept(iSocketFD, nil, nil);
X    if (*iSocketIOFD >= 0) {
X
X        /** setup socket for large buffers and non-blocking reading **/
X/*
X    iBufSize = 16384;
X    if (setsockopt(*iSocketIOFD, SOL_SOCKET, SO_RCVBUF,
X               (char *) &iBufSize, sizeof(int)) < 0 ||
X*/
X    /** convert msgsock to streams message-nondiscard-mode **/
X
X    if (fcntl(*iSocketIOFD, F_SETFL, FNDELAY) == -1)
X        Sock_Close(iSocketIOFD);
X
X    else {
X        FD_SET(*iSocketIOFD, &OPEN_READ_SOCKETS);
X        iErr = VEOS_SUCCESS;
X        }
X    }
X
X    return(iErr);
X
X} /* Sock_Accept */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Sock_Transmit                                        */
X
XTVeosErr Sock_Transmit(iSocketFD, sMessage, pLen)
X    int            iSocketFD;
X    char        *sMessage;
X    int            *pLen;
X{
X    int            iNetAction;
X    TVeosErr        iErr;
X    boolean        bTrap;
X
X    iErr = VEOS_FAILURE;
X
X
X    /** send the string to the given socket destination **/
X
X    iNetAction = write(iSocketFD, sMessage, *pLen);
X
X    CATCH_TRAP(SIGPIPE, bTrap);
X    if (bTrap)
X    iErr = TALK_CONN_CLOSED;
X
X
X    else if (iNetAction < 0) {
X
X    /** expected result when can't write **/
X
X    if (errno == EAGAIN || errno == EWOULDBLOCK)
X        iErr = TALK_SPEAK_BLOCKED;
X
X    else
X        perror("shell: write");
X        }
X
X    else if (iNetAction > 0) {
X
X    *pLen = iNetAction;
X    iErr = VEOS_SUCCESS;
X    }
X
X    return(iErr);
X
X    } /* Sock_Transmit */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Sock_Receive                                            */
X
XTVeosErr Sock_Receive(iSocketFD, sBuffer, iBufferSize)
X    int            iSocketFD;
X    char        *sBuffer;
X    int            *iBufferSize;
X{
X    TVeosErr            iErr;
X    int            iNetAction;
X
X
X    iErr = VEOS_FAILURE;                /* pessimism */
X
X
X    /** look for unread data in socket **/
X
X    iNetAction = read(iSocketFD, sBuffer, *iBufferSize);
X
X
X
X    /** connection still open, but no data **/
X
X    if (iNetAction < 0) {
X
X    /** expected result when no data **/
X
X    if (errno == EAGAIN || errno == EWOULDBLOCK)
X        iErr = TALK_LISTEN_BLOCKED;
X
X    else
X        perror("shell: read");
X        }
X
X
X    /** there was some data in the socket **/
X
X    else if (iNetAction > 0) {
X
X    iErr = VEOS_SUCCESS;
X    *iBufferSize = iNetAction;
X    }
X
X
X    /** conneciton closed from other end **/
X
X    else
X        iErr = TALK_CONN_CLOSED;
X
X
X    return(iErr);
X
X    } /* Sock_Receive */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X ** Inet Socket Close
X **
X ** usage:  status = Sock_Close( &socketFD );
X ** params: pointer to file descriptor of socket
X ** returns: VEOS_SUCCESS or TALK_CLOSE
X **/
X
XTVeosErr Sock_Close(iSocketFD)
X    int           *iSocketFD;
X{
X    TVeosErr    iErr;
X
X    iErr = VEOS_SUCCESS;
X
X
X    if (*iSocketFD != TALK_BOGUS_FD) {
X
X    FD_CLR(*iSocketFD, &OPEN_WRITE_SOCKETS);
X    FD_CLR(*iSocketFD, &OPEN_READ_SOCKETS);
X
X    shutdown(*iSocketFD, 2);
X
X    if (close(*iSocketFD) == -1)
X        iErr = TALK_CLOSE;
X
X    else
X        *iSocketFD = TALK_BOGUS_FD;
X    }
X
X    return(iErr);
X
X} /* Sock_Close */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X *                           local routines                    *
X ****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Sock_MixItUp                                        */
X
XTVeosErr Sock_MixItUp(iPortNumber, sProtocolName, iProto)
X    char        *sProtocolName;
X    int            *iPortNumber, *iProto;
X{
X    struct protoent     *protocolInfo, *getprotobyname();
X    TVeosErr        iErr;
X
X    iErr = VEOS_FAILURE;
X
X    if (*iPortNumber > 0) {
X
X    protocolInfo = getprotobyname(sProtocolName);
X    if (protocolInfo == nil)
X        iErr = TALK_PROTOCOL;
X
X    else {
X        *iProto = protocolInfo->p_proto;
X        iErr = VEOS_SUCCESS;
X        }
X    }
X
X    return(iErr);
X
X    } /* Sock_MixItUp */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Sock_ResolveHost(sHostName, pIpAddr)
X    char        *sHostName;
X    u_long        *pIpAddr;
X{
X    TVeosErr        iErr;
X
X
X    /** host address may already be in internet form **/
X
X    if (isdigit(sHostName[0]))
X    iErr = Sock_StrAddr2IP(sHostName, pIpAddr);
X
X    else
X    iErr = Sock_StrHost2IP(sHostName, pIpAddr);
X
X
X    return(iErr);
X
X} /* Sock_ResolveHost */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Sock_StrHost2IP(sHostName, pIpAddr)
X    char     *sHostName;
X    u_long    *pIpAddr;
X{
X    TVeosErr        iErr;
X    struct hostent      *hostInfo, *gethostbyname();
X    TPHostNode        pFinger;
X
X    iErr = VEOS_FAILURE;
X
X    if (sHostName) {
X
X    /** try to find this host in hash table first **/
X
X    for (pFinger = SOCK_HOSTS[sHostName[0] - 'a'];
X         pFinger;
X         pFinger = pFinger->pNext) {
X
X        if (strcmp(pFinger->sHostName, sHostName) == 0) {
X        iErr = VEOS_SUCCESS;
X        break;
X        }
X        }
X
X
X    if (!pFinger) {
X
X        /** find host by calling unix kernel **/
X
X        iErr = TALK_HOST;
X        if (hostInfo = gethostbyname(sHostName)) {
X
X        iErr = Shell_NewBlock(sizeof(THostNode), &pFinger, "host-node");
X        if (iErr == VEOS_SUCCESS) {
X
X            pFinger->sHostName = strdup(sHostName);
X            pFinger->lHost = *(u_long *) hostInfo->h_addr_list[0];
X
X
X            /** insert new host into hash table **/
X
X            pFinger->pNext = SOCK_HOSTS[sHostName[0] - 'a'];
X            SOCK_HOSTS[sHostName[0] - 'a'] = pFinger;
X            }
X        }
X        }
X
X    if (pFinger)
X        *pIpAddr = pFinger->lHost;
X    }
X
X    return(iErr);
X
X    } /* Sock_StrHost2IP */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Sock_IP2StrHost(lIPAddr, sHostName)
X    u_long    lIPAddr;
X    char     *sHostName;
X{
X    TVeosErr        iErr;
X    struct hostent      *hostInfo, *gethostbyaddr();
X    char        *pFinger;
X
X    iErr = VEOS_FAILURE;
X
X    if (sHostName) {
X
X    if (hostInfo = gethostbyaddr((char *) &lIPAddr, sizeof(u_long), AF_INET)) {
X        strcpy(sHostName, hostInfo->h_name);
X
X        if (pFinger = strchr(sHostName, '.'))
X        pFinger[0] = '\0';
X
X        iErr = VEOS_SUCCESS;
X        }
X    else
X        iErr = TALK_HOST;
X    }
X
X    return(iErr);
X
X    } /* Sock_IP2StrHost */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Sock_StrAddr2IP(sHostName, pIpAddr)
X    char     *sHostName;
X    u_long    *pIpAddr;
X{
X    u_long    lResult, lTemp;
X    char     *pCharFinger;
X    TVeosErr    iErr;
X
X    iErr = VEOS_FAILURE;
X    if (sHostName) {
X
X    lResult = 0;
X    pCharFinger = sHostName;
X
X
X    /* first byte */
X    lTemp = (u_long) atoi(pCharFinger);
X    lResult |= lTemp << 24;
X
X
X    /* second byte */
X    pCharFinger = strchr(pCharFinger, '.');
X    pCharFinger ++;
X
X    lTemp = (u_long) atoi(pCharFinger);
X    lResult |= lTemp << 16;
X
X
X    /* third byte */
X    pCharFinger = strchr(pCharFinger, '.');
X    pCharFinger ++;
X
X    lTemp = (u_long) atoi(pCharFinger);
X    lResult |= lTemp << 8;
X
X
X    /* fourth byte */
X    pCharFinger = strchr(pCharFinger, '.');
X    pCharFinger ++;
X
X    lTemp = (u_long) atoi(pCharFinger);
X    lResult |= lTemp;
X
X
X    *pIpAddr = lResult;
X
X    iErr = VEOS_SUCCESS;
X    }
X
X    return(iErr);
X
X    } /* Sock_StrAddr2IP */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Sock_IP2StrAddr(lIpAddr, sHostName)
X    u_long    lIpAddr;
X    char     *sHostName;
X{
X    TVeosErr        iErr;
X
X    iErr = VEOS_FAILURE;
X    if (sHostName) {
X
X    sprintf(sHostName, "%d.%d.%d.%d",
X        (lIpAddr >> 24) & 0x000000FF,
X        (lIpAddr >> 16) & 0x000000FF,
X        (lIpAddr >> 8) & 0x000000FF,
X        lIpAddr & 0x000000FF);
X
X    iErr = VEOS_SUCCESS;
X    }
X
X    return(iErr);
X
X    } /* Sock_IP2StrAddr */
X/****************************************************************************************/
X
X
X
X
X
X
END_OF_FILE
if test 16709 -ne `wc -c <'src/kernel_current/talk/socket.c'`; then
    echo shar: \"'src/kernel_current/talk/socket.c'\" unpacked with wrong size!
fi
# end of 'src/kernel_current/talk/socket.c'
fi
if test -f 'src/xlisp/xcore/c/xldmem.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xldmem.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xldmem.c'\" \(18074 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xldmem.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xldmem.c
X* RCS:          $Header: xldmem.c,v 1.6 89/11/25 05:18:06 mayer Exp $
X* Description:  xlisp dynamic memory management routines.
X* Author:       David Michael Betz; Niels Mayer
X* Created:
X* Modified:     Sat Nov 25 05:17:34 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xldmem.c,v 1.6 89/11/25 05:18:06 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* node flags */
X#define MARK    1
X#define LEFT    2
X
X/* macro to compute the size of a segment */
X#define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
X
X/* external variables */
Xextern LVAL obarray,s_gcflag,s_gchook,s_unbound,true;
Xextern LVAL xlenv,xlfenv,xldenv;
Xextern char buf[];
X
X/* variables local to xldmem.c and xlimage.c */
XSEGMENT *segs,*lastseg,*fixseg,*charseg;
Xint anodes,nsegs,gccalls;
Xlong nnodes,nfree,total;
XLVAL fnodes;
X
X/* external procedures */
Xextern char *malloc();
Xextern char *calloc();
X
X/* forward declarations */
XFORWARD LVAL newnode();
XFORWARD unsigned char *stralloc();
XFORWARD SEGMENT *newsegment();
X
X/* Include hybrid-class functions: *//* JSP */
X#define MODULE_XLDMEM_C_GLOBALS
X#include "../../xmodules.h"
X#undef MODULE_XLDMEM_C_GLOBALS
X
X/* cons - construct a new cons node */
XLVAL cons(x,y)
X  LVAL x,y;
X{
X    LVAL nnode;
X
X    /* get a free node */
X    if ((nnode = fnodes) == NIL) {
X    xlstkcheck(2);
X    xlprotect(x);
X    xlprotect(y);
X    gc();
X    if ((nnode = fnodes) == NIL)
X        xlabort("insufficient node space");
X    xlpop();
X    xlpop();
X    }
X
X    /* unlink the node from the free list */
X    fnodes = cdr(nnode);
X    --nfree;
X
X    /* initialize the new node */
X    nnode->n_type = CONS;
X    rplaca(nnode,x);
X    rplacd(nnode,y);
X
X    /* return the new node */
X    return (nnode);
X}
X
X/* cvstring - convert a string to a string node */
XLVAL cvstring(str)
X  char *str;
X{
X    LVAL val;
X    xlsave1(val);
X    val = newnode(STRING);
X    val->n_strlen = strlen(str) + 1;
X    val->n_string = stralloc(getslength(val));
X    strcpy(getstring(val),str);
X    xlpop();
X    return (val);
X}
X
X/* newstring - allocate and initialize a new string */
XLVAL newstring(size)
X  int size;
X{
X    LVAL val;
X    xlsave1(val);
X    val = newnode(STRING);
X    val->n_strlen = size;
X    val->n_string = stralloc(getslength(val));
X    strcpy(getstring(val),"");
X    xlpop();
X    return (val);
X}
X
X/* cvsymbol - convert a string to a symbol */
XLVAL cvsymbol(pname)
X  char *pname;
X{
X    LVAL val;
X    xlsave1(val);
X    val = newvector(SYMSIZE);
X    val->n_type = SYMBOL;
X    setvalue(val,s_unbound);
X    setfunction(val,s_unbound);
X    setpname(val,cvstring(pname));
X    xlpop();
X    return (val);
X}
X
X/* cvsubr - convert a function to a subr or fsubr */
XLVAL cvsubr(fcn,type,offset)
X  LVAL (*fcn)(); int type,offset;
X{
X    LVAL val;
X    val = newnode(type);
X    val->n_subr = fcn;
X    val->n_offset = offset;
X    return (val);
X}
X
X/* cvfile - convert a file pointer to a stream */
XLVAL cvfile(fp)
X  FILE *fp;
X{
X    LVAL val;
X    val = newnode(STREAM);
X    setfile(val,fp);
X    setsavech(val,'\0');
X    return (val);
X}
X
X/* cvfixnum - convert an integer to a fixnum node */
XLVAL cvfixnum(n)
X  FIXTYPE n;
X{
X    LVAL val;
X    if (n >= SFIXMIN && n <= SFIXMAX)
X    return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
X    val = newnode(FIXNUM);
X    val->n_fixnum = n;
X    return (val);
X}
X
X/* cvflonum - convert a floating point number to a flonum node */
XLVAL cvflonum(n)
X  FLOTYPE n;
X{
X    LVAL val;
X    val = newnode(FLONUM);
X    val->n_flonum = n;
X    return (val);
X}
X
X/* cvchar - convert an integer to a character node */
XLVAL cvchar(n)
X  int n;
X{
X    if (n >= CHARMIN && n <= CHARMAX)
X    return (&charseg->sg_nodes[n-CHARMIN]);
X    xlerror("character code out of range",cvfixnum((FIXTYPE)n));
X}
X
X/* newustream - create a new unnamed stream */
XLVAL newustream()
X{
X    LVAL val;
X    val = newnode(USTREAM);
X    sethead(val,NIL);
X    settail(val,NIL);
X    return (val);
X}
X
X/* newobject - allocate and initialize a new object */
XLVAL newobject(cls,size)
X  LVAL cls; int size;
X{
X    LVAL val;
X    val = newvector(size+1);
X    val->n_type = OBJECT;
X    setelement(val,0,cls);
X    return (val);
X}
X
X/* newclosure - allocate and initialize a new closure */
XLVAL newclosure(name,type,env,fenv)
X  LVAL name,type,env,fenv;
X{
X    LVAL val;
X    val = newvector(CLOSIZE);
X    val->n_type = CLOSURE;
X    setname(val,name);
X    settype(val,type);
X    setenv(val,env);
X    setfenv(val,fenv);
X    return (val);
X}
X
X/* newstruct - allocate and initialize a new structure node */
XLVAL newstruct(type,size)
X  LVAL type; int size;
X{
X    LVAL val;
X    val = newvector(size+1);
X    val->n_type = STRUCT;
X    setelement(val,0,type);
X    return (val);
X}
X
X/* newvector - allocate and initialize a new vector node */
XLVAL newvector(size)
X  int size;
X{
X    LVAL vect;
X    int bsize;
X    xlsave1(vect);
X    vect = newnode(VECTOR);
X    vect->n_vsize = 0;
X    if (bsize = size * sizeof(LVAL)) {
X    if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
X        gc();
Xprintf( "\nnewvector .A:  size d= %d, bsize d= %d", size, bsize );
X        if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
X        xlfail("insufficient vector space");
X    }
X    vect->n_vsize = size;
X    total += (long) bsize;
X    }
X    xlpop();
X    return (vect);
X}
X
X/* newnode - allocate a new node */
XLOCAL LVAL newnode(type)
X  int type;
X{
X    LVAL nnode;
X
X    /* get a free node */
X    if ((nnode = fnodes) == NIL) {
X    gc();
X    if ((nnode = fnodes) == NIL)
X        xlabort("insufficient node space");
X    }
X
X    /* unlink the node from the free list */
X    fnodes = cdr(nnode);
X    nfree -= 1L;
X
X    /* initialize the new node */
X    nnode->n_type = type;
X    rplacd(nnode,NIL);
X
X    /* return the new node */
X    return (nnode);
X}
X
X/* stralloc - allocate memory for a string adding a byte for the terminator */
XLOCAL unsigned char *stralloc(size)
X  int size;
X{
X    unsigned char *sptr;
X
X    /* allocate memory for the string copy */
X    if ((sptr = (unsigned char *)malloc(size)) == NULL) {
X    gc();
X    if ((sptr = (unsigned char *)malloc(size)) == NULL)
X        xlfail("insufficient string space");
X    }
X    total += (long)size;
X
X    /* return the new string memory */
X    return (sptr);
X}
X
X/* gc - garbage collect (only called here and in xlimage.c) */
Xgc()
X{
X    register LVAL **p,*ap,tmp;
X    char buf[STRMAX+1];
X    LVAL *newfp,fun;
X
X    /* print the start of the gc message */
X    if (s_gcflag && getvalue(s_gcflag)) {
X    sprintf(buf,"[ gc: total %ld, ",nnodes);
X    stdputstr(buf);
X    }
X
X/* Include hybrid-class functions: *//* JSP */
X#define MODULE_XLDMEM_C_GC
X#include "../../xmodules.h"
X#undef MODULE_XLDMEM_C_GC
X
X    /* mark the obarray, the argument list and the current environment */
X    if (obarray)   mark(obarray);
X    if (xlenv)     mark(xlenv  );
X    if (xlfenv)    mark(xlfenv );
X    if (xldenv)    mark(xldenv );
X
X
X    /* mark the evaluation stack */
X    for (p = xlstack; p < xlstktop; ++p) {
X    if (tmp = **p)   mark(tmp);
X    }
X
X    /* mark the argument stack */
X    for (ap = xlargstkbase; ap < xlsp; ++ap) {
X    if (tmp = *ap)   mark(tmp);
X    }
X
X    /* sweep memory collecting all unmarked nodes */
X    sweep();
X
X    /* count the gc call */
X    ++gccalls;
X
X    if (nfree < (long)anodes)   addseg();     /*91Jan17jsp*/
X
X    /* Call the *gc-hook* if necessary */
X    if (s_gchook                   != NIL   &&
X        (fun = getvalue(s_gchook)) != NIL
X    ) {
X
X    /* Rebind the hook fn to NIL: *//*91Jan17jsp*/
X    LVAL olddenv = xldenv;            /*91Jan17jsp*/
X    xldbind(s_gchook,NIL);            /*91Jan17jsp*/
X
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(cvfixnum((FIXTYPE)2));
X    pusharg(cvfixnum((FIXTYPE)nnodes));
X    pusharg(cvfixnum((FIXTYPE)nfree));
X    xlfp = newfp;
X
X    xlapply(2);
X
X    /* Restore *GC-HOOK* binding: *//*91Jan17jsp*/
X    xlunbind(olddenv);        /*91Jan17jsp*/
X    }
X
X    /* print the end of the gc message */
X    if (s_gcflag && getvalue(s_gcflag)) {
X    sprintf(buf,"%ld free ]\n",nfree);
X    stdputstr(buf);
X    }
X}
X
X/* mark - mark all accessible nodes */
XLOCAL mark(ptr)
X  LVAL ptr;
X{
X    register LVAL this,prev,tmp;
X    int type,i,n;
X
X    /* initialize */
X    prev = NIL;
X    this = ptr;
X
X    /* mark this list */
X    for (;;) {
X
X    /* descend as far as we can */
X    while (!(this->n_flags & MARK)) {
X
X        /* check cons and unnamed stream nodes */
X        if ((type = ntype(this)) == CONS || type == USTREAM) {
X
X        if (tmp = car(this)) {
X
X            this->n_flags |= MARK|LEFT;
X            rplaca(this,prev);
X
X        } else if (tmp = cdr(this)) {
X
X            this->n_flags |= MARK;
X            rplacd(this,prev);
X
X        } else {                /* both sides nil */
X
X            this->n_flags |= MARK;
X            break;
X        }
X        prev = this;            /* step down the branch */
X        this = tmp;
X
X        } else {
X
X        /* mark other node types */
X        this->n_flags |= MARK;
X        switch (type) {
X/* Include hybrid-class functions: *//* JSP */
X#define MODULE_XLDMEM_C_MARK
X#include "../../xmodules.h"
X#undef MODULE_XLDMEM_C_MARK
X        case SYMBOL:
X        case OBJECT:
X        case VECTOR:
X        case CLOSURE:
X        case STRUCT:
X                vector:
X            for (i = 0, n = getsz(this); --n >= 0; ++i)
X            if (tmp = getelement(this,i))
X                mark(tmp);
X            break;
X        }
X        break;
X        }
X        }
X
X    /* backup to a point where we can continue descending */
X    for (;;) {
X
X        /* make sure there is a previous node */
X        if (!prev) {
X                /* no previous node, must be done */
X        return;
X
X        } else {
X
X        if (prev->n_flags &   LEFT) {    /* came from left side */
X            prev->n_flags &= ~LEFT;
X            tmp = car(prev);
X            rplaca(prev,this);
X            if (this = cdr(prev)) {
X            rplacd(prev,tmp);
X            break;
X            }
X        } else {                        /* came from right side */
X            tmp = cdr(prev);
X            rplacd(prev,this);
X        }
X        this = prev;            /* step back up the branch */
X        prev = tmp;
X        }
X        }
X    }
X}
X
X/* sweep - sweep all unmarked nodes and add them to the free list */
XLOCAL sweep()
X{
X    SEGMENT *seg;
X    LVAL p;
X    int n;
X
X    /* empty the free list */
X    fnodes = NIL;
X    nfree = 0L;
X
X    /* add all unmarked nodes */
X    for (seg = segs; seg; seg = seg->sg_next) {
X    if (seg == fixseg)     /* don't sweep the fixnum segment */
X        continue;
X    else if (seg == charseg) /* don't sweep the character segment */
X        continue;
X    p = &seg->sg_nodes[0];
X    for (n = seg->sg_size; --n >= 0; ++p) {
X        if (p->n_flags &   MARK) {
X        p->n_flags &= ~MARK;
X        } else {
X        switch (ntype(p)) {
X        case STRING:
X            if (getstring(p) != NULL) {
X                total -= (long)getslength(p);
X                free(getstring(p));
X            }
X            break;
X        case STREAM:
X            if (getfile(p))
X                osclose(getfile(p));
X            break;
X/* Include hybrid-class functions: *//* JSP */
X#define MODULE_XLDMEM_C_SWEEP
X#include "../../xmodules.h"
X#undef MODULE_XLDMEM_C_SWEEP
X        case SYMBOL:
X        case OBJECT:
X        case VECTOR:
X        case CLOSURE:
X        case STRUCT:
X            vector:
X            if (p->n_vsize) {
X                total -= (long) (p->n_vsize * sizeof(LVAL));
X                free(p->n_vdata);
X            }
X            break;
X        }
X        p->n_type = FREE;
X        rplaca(p,NIL);
X        rplacd(p,fnodes);
X        fnodes = p;
X        nfree += 1L;
X        }
X        }
X    }
X}
X
X/* addseg - add a segment to the available memory */
XLOCAL int addseg()
X{
X    SEGMENT *newseg;
X    LVAL p;
X    int n;
X
X    /* allocate the new segment */
X    if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
X    return (FALSE);
X
X    /* add each new node to the free list */
X    p = &newseg->sg_nodes[0];
X    for (n = anodes; --n >= 0; ++p) {
X    rplacd(p,fnodes);
X    fnodes = p;
X    }
X
X    /* return successfully */
X    return (TRUE);
X}
X
X/* newsegment - create a new segment (only called here and in xlimage.c) */
XSEGMENT *newsegment(n)
X  int n;
X{
X    SEGMENT *newseg;
X
X    /* allocate the new segment */
X    if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
X    return (NULL);
X
X    /* initialize the new segment */
X    newseg->sg_size = n;
X    newseg->sg_next = NULL;
X    if (segs)
X    lastseg->sg_next = newseg;
X    else
X    segs = newseg;
X    lastseg = newseg;
X
X    /* update the statistics */
X    total += (long)segsize(n);
X    nnodes += (long)n;
X    nfree += (long)n;
X    ++nsegs;
X
X    /* return the new segment */
X    return (newseg);
X}
X
X/* stats - print memory statistics */
XLOCAL stats()
X{
X    sprintf(buf,"Nodes:       %ld\n",nnodes); stdputstr(buf);
X    sprintf(buf,"Free nodes:  %ld\n",nfree);  stdputstr(buf);
X    sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
X    sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
X    sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
X    sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
X}
X
X/* xgc - xlisp function to force garbage collection */
XLVAL xgc()
X{
X    /* make sure there aren't any arguments */
X    xllastarg();
X
X    /* garbage collect */
X    gc();
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xexpand - xlisp function to force memory expansion */
XLVAL xexpand()
X{
X    LVAL num;
X    int n,i;
X
X    /* get the new number to allocate */
X    if (moreargs()) {
X    num = xlgafixnum();
X    n = getfixnum(num);
X    }
X    else
X    n = 1;
X    xllastarg();
X
X    /* allocate more segments */
X    for (i = 0; i < n; i++)
X    if (!addseg())
X        break;
X
X    /* return the number of segments added */
X    return (cvfixnum((FIXTYPE)i));
X}
X
X/* xalloc - xlisp function to set the number of nodes to allocate */
XLVAL xalloc()
X{
X    int n,oldn;
X    LVAL num;
X
X    /* get the new number to allocate */
X    num = xlgafixnum();
X    n = getfixnum(num);
X
X    /* make sure there aren't any more arguments */
X    xllastarg();
X
X    /* set the new number of nodes to allocate */
X    oldn = anodes;
X    anodes = n;
X
X    /* return the old number */
X    return (cvfixnum((FIXTYPE)oldn));
X}
X
X/* xmem - xlisp function to print memory statistics */
XLVAL xmem()
X{
X    /* allow one argument for compatiblity with common lisp */
X    if (moreargs()) xlgetarg();
X    xllastarg();
X
X    /* print the statistics */
X    stats();
X
X    /* return nil */
X    return (NIL);
X}
X
X#ifdef SAVERESTORE
X/* xsave - save the memory image */
XLVAL xsave()
X{
X    unsigned char *name;
X
X    /* get the file name, verbose flag and print flag */
X    name = getstring(xlgetfname());
X    xllastarg();
X
X    /* save the memory image */
X    return (xlisave(name) ? true : NIL);
X}
X
X/* xrestore - restore a saved memory image */
XLVAL xrestore()
X{
X    extern jmp_buf top_level;
X    unsigned char *name;
X
X    /* get the file name, verbose flag and print flag */
X    name = getstring(xlgetfname());
X    xllastarg();
X
X    /* restore the saved memory image */
X    if (!xlirestore(name))
X    return (NIL);
X
X    /* return directly to the top level */
X    stdputstr("[ returning to the top level ]\n");
X    xllongjmp(top_level,1);
X}
X#endif
X
X/* xlminit - initialize the dynamic memory module */
Xxlminit()
X{
X    LVAL p;
X    int i;
X
X    /* initialize our internal variables */
X    segs = lastseg = NULL;
X    nnodes = nfree = total = 0L;
X    nsegs = gccalls = 0;
X    anodes = NNODES;
X    fnodes = NIL;
X
X    /* Since newvector etc depend on NULL==0, */  /* JSP */
X    /* do a quick check:                      */  /* JSP */
X    {                          /* JSP */
X        LVAL*v = (LVAL*)calloc(sizeof(LVAL),1);   /* JSP */
X        if (*v != NULL) xlfatal("NULL != 0");     /* JSP */
X        free(v);                  /* JSP */
X    }                          /* JSP */
X
X    /* allocate the fixnum segment */
X    if ((fixseg = newsegment(SFIXSIZE)) == NULL)
X    xlfatal("insufficient memory");
X
X    /* initialize the fixnum segment */
X    p = &fixseg->sg_nodes[0];
X    for (i = SFIXMIN; i <= SFIXMAX; ++i) {
X    p->n_type = FIXNUM;
X    p->n_fixnum = i;
X    ++p;
X    }
X
X    /* allocate the character segment */
X    if ((charseg = newsegment(CHARSIZE)) == NULL)
X    xlfatal("insufficient memory");
X
X    /* initialize the character segment */
X    p = &charseg->sg_nodes[0];
X    for (i = CHARMIN; i <= CHARMAX; ++i) {
X    p->n_type = CHAR;
X    p->n_chcode = i;
X    ++p;
X    }
X
X    /* initialize structures that are marked by the collector */
X    obarray = xlenv = xlfenv = xldenv = NIL;
X    s_gcflag = s_gchook = NIL;
X
X/* Include hybrid-class functions: *//* JSP */
X#define MODULE_XLDMEM_C_XLMINIT
X#include "../../xmodules.h"
X#undef MODULE_XLDMEM_C_XLMINIT
X
X    /* allocate the evaluation stack */
X    if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
X    xlfatal("insufficient memory");
X    xlstack = xlstktop = xlstkbase + EDEPTH;
X
X    /* allocate the argument stack */
X    if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
X    xlfatal("insufficient memory");
X    xlargstktop = xlargstkbase + ADEPTH;
X    xlfp = xlsp = xlargstkbase;
X    *xlsp++ = NIL;
X}
X
END_OF_FILE
if test 18074 -ne `wc -c <'src/xlisp/xcore/c/xldmem.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xldmem.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xldmem.c'
fi
echo shar: End of archive 8 \(of 16\).
cp /dev/null ark8isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 16 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0